Celestin Apprentice 7/Apprentice-Release7.iso/Environments/Clean 1.2.4/IOInterface/menuDevice.icl

Modula Implementation | 1997-04-24 | 15.3 KB | 408 lines | [TEXT/3PRM]

implementation module menuDevice;


import StdClass;
import    StdBool, StdChar, StdInt, StdMisc, StdString;
import    desk, windows;
import    menuInternal, commonDef;
from    deltaMenu    import SelectMenuRadioItem;
from    dialogAbout    import OpenAboutDialog;


MenuDeviceError :: String String -> .x;
MenuDeviceError f error = Error f "menuDevice" error;


MenuFunctions :: DeviceFunctions s;
MenuFunctions = (    ShowMenu,
                        OpenMenu,
                            MenuIO,
                        CloseMenu,
                    HideMenu
                );


ShowMenu :: !(IOState s) -> IOState s;
ShowMenu ioState
    =    IOStateSetToolbox (DrawMenuBar (SetMenuSystem menus tb)) ioState2;
    where {
        (menus,    ioState1)    = IOStateGetDevice  ioState MenuDevice;
        (tb,    ioState2)    = IOStateGetToolbox ioState1;
    };

CloseMenu    :: !(IOState s) -> IOState s;
CloseMenu ioState
    =    IOStateRemoveDevice (IOStateSetToolbox tb1 ioState2) MenuDevice;
    where {
        (menus,    ioState1)    = IOStateGetDevice  ioState MenuDevice;
        (tb,    ioState2)    = IOStateGetToolbox ioState1;
        tb1                    = DisposeMenuSystemState menus tb;
    };

HideMenu :: !(IOState s) -> IOState s;
HideMenu ioState
    =    IOStateSetDevice (IOStateSetToolbox tb2 ioState2) menus1;
    where {
        (menus,    ioState1)    = IOStateGetDevice  ioState MenuDevice;
        (tb,    ioState2)    = IOStateGetToolbox ioState1;
        (menus1, tb1)        = GetMenuSystem menus tb;
        tb2                    = DrawMenuBar (ClearMenuBar tb1);
    };


//    Opening menu's:

OpenMenu :: !(DeviceSystem s (IOState s)) !(IOState s) -> IOState s;
OpenMenu (MenuSystem mDefs) ioState
    =    IOStateSetDevice (IOStateSetToolbox (DrawMenuBar tb3) ioState1) menuSystem;
    where {
        (menuSystem,    tb3)    = GetMenuSystem (MenuSystemState (m_and_hs, cuts, 0, SystemAble)) tb2;
        (m_and_hs, cuts,tb2)    = CreateApple_and_Handles (ProperRadioMenuItems mDefs) tb1;
        tb1                        = ClearMenuBar tb;
        (tb, ioState1)            = IOStateGetToolbox ioState;
    };
OpenMenu _ _
    =    MenuDeviceError "OpenMenu" "argument is no MenuSystem";

CreateApple_and_Handles    :: ![MenuDef s (IOState s)] !Toolbox -> (![MenuHandle s], ![Char], !Toolbox);
CreateApple_and_Handles [] tb
    =    ([appleMenu, emptyMenu], [], tb2);
    where {
        (appleMenu, tb1) = AppleMenu tb;
        (emptyMenu, tb2) = EmptyMenuHandle MacPullDownStartId tb1;
    };
CreateApple_and_Handles mDefs tb
    =    CreateHandles [appleMenu] mDefs MacPullDownStartId MacSubMenuStartId [] tb1;
    where {
        (appleMenu, tb1) = AppleMenu tb;
    };

CreateHandles :: ![MenuHandle s] ![MenuDef s (IOState s)] !MenuId !MenuId ![Char] !Toolbox
    ->    (![MenuHandle s], ![Char], !Toolbox);
CreateHandles m_and_hs [mDef=: PullDownMenu id s able items : mDefs] pId sId keys tb
    =    CreateHandles (Append m_and_hs menuH`) mDefs pId` sId` keys` tb3;
    where {
        (menuH,                        tb1)= NewMenuHandle mDef pId tb;
        (iNr, menuH`, sId`, keys`,    tb2)= Append_menu_items 1 menuH items sId keys tb1;
        tb3                                = Insert_menu menuH` tb2;
        pId`                            = IncrPullDownMenuId pId;
    };
CreateHandles m_and_hs _ _ _ keys tb = (m_and_hs, keys, tb);

Append_menu_items :: !Int !(MenuHandle s) ![MenuElement s (IOState s)] !MenuId ![Char] !Toolbox
    ->    (!Int, !MenuHandle s, !MenuId, ![Char], !Toolbox);
Append_menu_items iNr menuH [subMenu=:SubMenuItem id t s subItems : menuItems] sId keys tb
    =    Append_menu_items (inc iNr) menuH` menuItems sId` keys` tb4;
    where {
        (submenuH, tb1)    = NewMenuElementHandle subMenu sId tb;
        (iNr`, submenuH`, sId`, keys`, tb2)
                        = Append_menu_items 1 submenuH subItems (IncrSubMenuId sId) keys tb1;
        tb3                = Insert_menu submenuH` tb2;
        (menuH`, tb4)    = Append_menu iNr menuH macItem submenuH` tb3;
        macItem            = MenuElementToMacElement (SubMenuItem sId t s subItems);
    };
Append_menu_items iNr menuH [item=:MenuRadioItems id items : menuItems] sId keys tb
    =    Append_menu_items iNr` menuH`` menuItems sId keys` tb3;
    where {
        (radioH, tb1)    = NewMenuElementHandle item 0 tb;
        (iNr`, menuH`, radioH`, keys`, tb2)
                        = Append_radio_items iNr menuH radioH id items keys tb1;
        (menuH``, tb3)    = Append_menu iNr menuH` macItem radioH` tb2;
        macItem            = MenuElementToMacElement item;
    };
Append_menu_items iNr menuH [item=:MenuItemGroup id groupItems : menuItems] sId keys tb
    =    Append_menu_items iNr` menuH`` menuItems sId` keys` tb3;
    where {
        (itemH, tb1)    = NewMenuElementHandle item 0 tb;
        (iNr`, menuH`, itemH`, sId`, keys`, tb2)
                        = Append_group_items iNr menuH itemH groupItems sId keys tb1;
        (menuH``, tb3)    = Append_menu iNr menuH` macItem itemH` tb2;
        macItem            = MenuElementToMacElement item;
    };
Append_menu_items iNr menuH [item : menuItems] sId keys tb
    =    Append_menu_items (inc iNr) menuH` menuItems sId keys` tb2;
    where {
        (itemH,    tb1)    = NewMenuElementHandle item 0 tb;
        (menuH`,tb2)    = Append_menu iNr menuH macItem itemH tb1;
        macItem            = MenuElementToMacElement item`;
        (item`,    keys`)    = CheckShortcutKey item keys;
    };
Append_menu_items iNr menuH _ sId keys tb = (iNr, menuH, sId, keys, tb);

Append_group_items ::    !Int !(MenuHandle s) !(MenuHandle s) ![MenuElement s (IOState s)]
                        !MenuId ![Char] !Toolbox
    ->    (!Int, !MenuHandle s, !MenuHandle s, !MenuId, ![Char], !Toolbox);
Append_group_items iNr m_and_h (MenuItemGroupHandle id []) groupItems sId keys tb
    =    (iNr1, m_and_h2, MenuItemGroupHandle id itemGroupHs, sId1, keys1, tb1);
    where {
        (itemGroupHs, m_and_h2)                = SplitMenuHandle m_and_h1 (NrItems m_and_h);
        (iNr1, m_and_h1, sId1, keys1, tb1)    = Append_menu_items iNr m_and_h groupItems sId keys tb;
    };

Append_radio_items ::    !Int !(MenuHandle s) !(MenuHandle s) !MenuItemId
                        ![RadioElement s (IOState s)] ![Char] !Toolbox
    ->    (!Int, !MenuHandle s, !MenuHandle s, ![Char], !Toolbox);
Append_radio_items iNr m_and_h (MenuRadioItemsHandle []) theId radioItems keys tb
    =    (iNr1, m_and_h2, MenuRadioItemsHandle checkItemHs, keys1, tb1);
    where {
        (checkItemHs, m_and_h2)                = SplitMenuHandle m_and_h1 (NrItems m_and_h);
        (iNr1, m_and_h1, dummy, keys1, tb1)    = Append_menu_items iNr m_and_h radioItems1 0 keys tb;
        radioItems1                            = RadioToCheckItems theId radioItems;
    };

Append_menu    :: !Int !(MenuHandle s) (!String,!String) !(MenuHandle s) !Toolbox -> (!MenuHandle s,!Toolbox);
Append_menu iNr (PullDownHandle menu id macId able items) (title, macStr) itemH tb
|    macStr == ""    = (menuH, tb );
                    = (menuH, tb2);
    where {
        menuH    = PullDownHandle menu id macId able (Append items itemH);
        tb1        = AppendMenu menu macStr tb;
        tb2        = SetItem menu iNr title tb1;
    };
Append_menu iNr (SubMenuItemHandle menu id macId items) (title, macStr) itemH tb
|    macStr == ""    = (menuH, tb );
                    = (menuH, tb2);
    where {
        menuH    = SubMenuItemHandle menu id macId (Append items itemH);
        tb1        = AppendMenu menu macStr tb;
        tb2        = SetItem menu iNr title tb1;
    };

NrItems    :: !(MenuHandle s) -> Int;
NrItems (PullDownHandle        _ _ _ _ items)    = Length_new items;
NrItems (SubMenuItemHandle    _ _ _    items)    = Length_new items;
NrItems _                                    = 0;

MenuElementToMacElement    :: !(MenuElement s (IOState s)) -> (!String, !String);
MenuElementToMacElement (CheckMenuItem id t NoKey able mark f)
|    Checked mark && Enabled able        = (CheckItemTitle t, s +++ check);
|    Checked mark                        = (CheckItemTitle t, s +++ disable +++ check);
|    Enabled able                        = (CheckItemTitle t, s);
                                        = (CheckItemTitle t, s +++ disable);
    where {
        s      = "D";
        disable= "(";
        check  = "!" +++ toString (toChar 18);
    };
MenuElementToMacElement (CheckMenuItem id t (Key key) able mark f)
|    not (Checked mark)    && Enabled able    = (CheckItemTitle t, s +++ shortcut);
|    Checked mark        && Enabled able    = (CheckItemTitle t, s +++ check   +++ shortcut);
|    not (Checked mark)                    = (CheckItemTitle t, s +++ disable +++ shortcut);
                                        = (CheckItemTitle t, s +++ disable +++ check +++ shortcut);
    where {
        s        = "D";
        shortcut= KeyToShortcut key;
        disable = "(";
        check    = "!" +++ toString (toChar 18);
    };
MenuElementToMacElement (MenuItem id t NoKey able f)
|    Enabled able                        = (CheckItemTitle t, "D");
                                        = (CheckItemTitle t, "D(");
MenuElementToMacElement (MenuItem id t (Key key) able f)
|    Enabled able                        = (CheckItemTitle t, "D"  +++ shortcut);
                                        = (CheckItemTitle t, "D(" +++ shortcut);
    where {
        shortcut = KeyToShortcut key;
    };
MenuElementToMacElement (SubMenuItem id t s items)
|    Enabled s                            = (CheckItemTitle t, submenu_and_id +++ "D");
                                        = (CheckItemTitle t, submenu_and_id +++ "D(");
    where {
        submenu_and_id    = submenu +++ menu_id;
        submenu            = "/" +++  toString (toChar 27);        // /$1B signifies this item as a SubMenu.
        menu_id            = "!" +++  toString (toChar id);        // !id = the menu defining the SubMenu.
    };
MenuElementToMacElement MenuSeparator = ("-", "-(");
MenuElementToMacElement groupOrRadios = ("",  "");

KeyToShortcut :: !Char -> String;
KeyToShortcut c
|    c >= 'a' && c <= 'z'    = "/" +++ toString (toChar (toInt 'A' + (toInt c - toInt 'a')));
                            = "/" +++ toString c;

CheckShortcutKey :: !(MenuElement s (IOState s)) ![Char] -> (!MenuElement s (IOState s), ![Char]);
CheckShortcutKey item=:(MenuItem id t (Key c) s f) cs
|    ContainsChar cs c        = (MenuItem id t NoKey s f, cs);
                            = (item, [c : cs]);
CheckShortcutKey item=:(CheckMenuItem id t (Key c) s m f) cs
|    ContainsChar cs c        = (CheckMenuItem id t NoKey s m f, cs);
                            = (item, [c : cs]);
CheckShortcutKey item cs    = (item, cs);


RadioToCheckItems :: !MenuItemId ![RadioElement s (IOState s)] -> [MenuElement s (IOState s)];
RadioToCheckItems theId [MenuRadioItem id t c s f : items]
    =     [CheckMenuItem id t c s (RadioMark id theId) f : RadioToCheckItems theId items];
RadioToCheckItems theId items =  [];

RadioMark :: !MenuItemId !MenuItemId -> MarkState;
RadioMark id1 id2
|    id1 == id2    = Mark;
                = NoMark;


/*    Creation of correct internal menu numbers only.
    Note:    MacSubMenuEndId is 234 rather than 235 because the dialogs
            use 235 for generating pop up dialog items.
*/

MacPullDownStartId    :== 1;
MacPullDownEndId    :== 16;
MacSubMenuStartId    :== 17;
MacSubMenuEndId        :== 234;

IncrPullDownMenuId :: !MenuId -> MenuId;
IncrPullDownMenuId id
|    id < MacPullDownEndId    = inc id;
                            = MenuDeviceError    "Creating menus"
                                                "To many PullDownMenus in one MenuSystem";

IncrSubMenuId :: !MenuId -> MenuId;
IncrSubMenuId id
|    id < MacSubMenuEndId    = inc id;
                            = MenuDeviceError    "Creating menus"
                                                "To many SubMenus in one MenuSystem";


//    Ensure proper marking when a MenuRadioItem is selected:

ProperRadioMenuItems :: ![MenuDef s (IOState s)] -> [MenuDef s (IOState s)];
ProperRadioMenuItems [PullDownMenu id s able items : menus]
    =     [PullDownMenu id s able (MenuProperRadioItems items) : ProperRadioMenuItems menus];
ProperRadioMenuItems menus = menus;

MenuProperRadioItems :: ![MenuElement s (IOState s)] -> [MenuElement s (IOState s)];
MenuProperRadioItems [MenuRadioItems id radioItems : menuItems]
    =     [MenuRadioItems id (ProperRadioItems radioItems id) : MenuProperRadioItems menuItems];
MenuProperRadioItems [SubMenuItem id t s subItems : menuItems]
    =     [SubMenuItem id t s (MenuProperRadioItems subItems) : MenuProperRadioItems menuItems];
MenuProperRadioItems [MenuItemGroup id groupItems  : menuItems]
    =     [MenuItemGroup id (MenuProperRadioItems groupItems) : MenuProperRadioItems menuItems];
MenuProperRadioItems [item : menuItems]
    =     [item : MenuProperRadioItems menuItems];
MenuProperRadioItems menuItems = menuItems;

ProperRadioItems :: ![RadioElement s (IOState s)] !MenuItemId -> [RadioElement s (IOState s)];
ProperRadioItems [MenuRadioItem id s key able f : radioItems] theId
    =     [MenuRadioItem id s key able (MenuRadioFunction id f) : ProperRadioItems radioItems theId];
ProperRadioItems radioItems theId =  radioItems;

MenuRadioFunction :: !MenuItemId !(MenuFunction *s (IOState *s)) !*s !(IOState *s) -> (!*s, !IOState *s);
MenuRadioFunction theId f s ioState = f s (SelectMenuRadioItem theId ioState);

//    Doing menu I/O:

::    TraceResult    =    NoMenuEvent
                |    DeskEvent
                |    MenuEvent Int Int
                |    AboutEvent;

MenuIO :: !Event !*s !(IOState *s) -> (!Bool, !*s, !IOState *s);
MenuIO event s ioState
    =    MenuIO` menuTrace menus s (IOStateSetToolbox tb1 ioState2);
    where {
        (menus,        ioState1)    = IOStateGetDevice    ioState MenuDevice;
        (tb,        ioState2)    = IOStateGetToolbox    ioState1;
        (menuTrace, tb1)        = MenuTrace event menus tb;
    };

MenuIO` :: !TraceResult !(DeviceSystemState *s) !*s !(IOState *s) -> (!Bool, !*s, !IOState *s);
MenuIO` (MenuEvent h v) menus s ioState
|    found    = (True, s1, ioState1);
            = (True, s,  ioState );
    where {
        (s1, ioState1)    = f s ioState;
        (found, f)        = MenuSystemState_MenuFunction h v menus;
    };
MenuIO` AboutEvent menus s ioState
    =    (True, s1, ioState1);
    where {
        (s1, ioState1) = OpenAboutDialog s ioState;
    };
MenuIO` DeskEvent menus s ioState
    =     (True, s, ioState);
MenuIO` noMenuEvent menus s ioState
    =     (False, s, ioState);

MenuTrace :: !Event !(DeviceSystemState s) !Toolbox -> (!TraceResult, !Toolbox);
MenuTrace    event        =:(b,MouseDownEvent,mess,i,h,v,mods)
            menuSystem    =:(MenuSystemState (menus, cuts, handle, systemAble)) tb
|    region == menuBar                = MenuSelection barMenuId barItemNr menus tb2;
|    region == inSysWindow            = (NoMenuEvent, SystemClick (1,mess,i,h,v,mods) wPtr tb1);
                                    = (NoMenuEvent, tb1);
    where {
        (region, wPtr, tb1)            = FindWindow h v tb;
        (barMenuId, barItemNr, tb2)    = MenuSelect h v tb1;
        inSysWindow                    = 2;
        menuBar                        = 1;
    };
MenuTrace (b,KeyUpEvent,message,i,h,v,mods) menuSystem tb
|    commandKeyUp                    = (NoMenuEvent,    tb);
|    menuId <> 0                        = (DeskEvent,    tb2);
                                    = (NoMenuEvent,    tb2);
    where {
        (menuId, menuItemNr, tb1)    = MenuKey charCode tb;
        tb2                            = HiliteMenu 0 tb1;
        charCode                    = message bitand 255;
        commandKeyDown                = (mods bitand 256) <> 0;
        commandKeyUp                = (mods bitand 256) == 0;
    };
MenuTrace    event        =:(b,what,message,i,h,v,mods)
            menuSystem    =:(MenuSystemState (menus, cuts, handle, systemAble)) tb
|    (what <> KeyDownEvent && what <> AutoKeyEvent)
||    commandKeyUp                    = (NoMenuEvent, tb);
|    otherItem                        = MenuSelection menuId menuItemNr menus tb1;
                                    = (NoMenuEvent, tb1);
    where {
        (menuId, menuItemNr, tb1)    = MenuKey charCode tb;
        charCode                    = message bitand 255;
        otherItem                    = menuId <> 0;
        commandKeyUp                = (mods bitand 256) == 0;
    };

MenuSelection :: !Int !Int ![MenuHandle s] !Toolbox -> (!TraceResult, !Toolbox);
MenuSelection no_choice=:0 menuItem menuHs tb
    =    (NoMenuEvent, HiliteMenu 0 tb);
MenuSelection AppleMenuId menuItem menuHs tb
|    menuItem >= 3    = (DeskEvent,  OpenAccessory menuHs menuItem tb1);
|    menuItem == 1    = (AboutEvent, tb1);
                    = (NoMenuEvent,tb1);
    where {
        tb1 = HiliteMenu 0 tb;
    };
MenuSelection menuId menuItem menuHs tb
    =    (MenuEvent menuId menuItem, HiliteMenu 0 tb);


//    Change the title of the Apple menu:

IOStateChangeAppleMenuTitle    :: !String !(IOState s) -> IOState s;
IOStateChangeAppleMenuTitle applicationName ioState
    =    IOStateSetToolbox (MenusChangeAppleMenuTitle applicationName menus tb) ioState2;
    where {
        (tb,    ioState2) = IOStateGetToolbox ioState1;
        (menus,    ioState1) = IOStateGetDevice ioState MenuDevice;
    };

MenusChangeAppleMenuTitle :: !String !(DeviceSystemState s) !Toolbox -> Toolbox;
MenusChangeAppleMenuTitle name (MenuSystemState ([apple=:PullDownHandle menuH _ _ _ _ : _],_,_,_)) tb
    =    SetItem menuH 1 ("About " +++ name +++ "...") tb;


//    Providing an extra layer over desk:

OpenAccessory :: ![MenuHandle s] !Int !Toolbox -> Toolbox;
OpenAccessory [PullDownHandle appleH id macId able items : m_and_hs] item tb
    =    tb2;
    where {
        (acc, tb1)    = GetItem appleH item String256 tb;
        tb2            = OpenDeskAcc acc tb1;
    };

String256 :: String;
String256
    =    string128 +++ string128;
    where {
        string128 = "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@";
    };